package cldb;

use DBI;
use clmasterdefaults;
use C_client2;
use C_server2;
use Sys::Hostname;
use MIME::Base64;
use Time::HiRes qw(time);
use Carp qw(cluck);
use Data::Dumper;
use POSIX ();

#########################################################################
# Class level variables to record errors of last call.			#
#########################################################################

$::DEBUG=0;
my $cldb_errcode=0;
my $cldb_errstr=undef;

#########################################################################
# Records is an array of known record types with details of each field	#
# including whether it is optional or not, and what kind of validation	#
# and manipulation to apply when attempting to add records via the	#
# add_verified_record method.						#
#########################################################################

$::CONFDB_NPORT=11883;
{
	my $defaults=new clmasterdefaults("$::ENV{TRUECL_CFG}/master-defaults.xml");
	if(!defined($defaults)) {
		print STDERR "ERROR: ",clmasterdefaults::error(),"\n";
	}
	my $xx=$defaults->get_default_value("configdb_port",1);
	if(defined($xx)) {
		$::CONFDB_NPORT=$xx;
	}
}

my %records=(
	"globals" => {
		"var"		=> ["m",\&is_unique],
		"value"		=> ["m"]
		},
	"ports"	=> {
		"number"	=> ["m",\&is_unique,\&is_integer,\&is_nowhitespace],
		"type"		=> ["m"],
		"detail"	=> ["o"],
		},
	"topology" => {
		"name"		=> ["m",\&is_unique,\&is_nowhitespace],
		"lcards"	=> ["o"],
		"pcards"	=> ["o"],
		"type"		=> ["m",\&is_valid_nettype]
		},
	"applications" => {
		"name"		=> ["m",\&is_unique_app_in_cluster],
		"prefnode"	=> ["m",\&is_valid_app_preference],
		"nodes"		=> ["m",\&is_valid_node_list],
		"consistency"	=> ["m",\&is_valid_failover_type],
		"startscript"	=> ["o",\&is_valid_script],
		"stopscript"	=> ["o",\&is_valid_script],
		"migratescript"	=> ["o",\&is_valid_script],
		"starttimeout"	=> ["o",\&is_integer],
		"migratetimeout"=> ["o",\&is_integer],
		"stoptimeout"	=> ["o",\&is_integer],
		"storage"	=> ["m",\&is_valid_storage_spec],
		"lmigrate"	=> ["m",\&is_integer],
		},
	"application_ips" => {
		"name"		=> ["m",],
		"network"	=> ["m",],
		"ips"		=> ["m",],
		"netmask"	=> ["o",\&is_netmask],
		"broadcast"	=> ["o",\&is_ip_addr],
		"version"	=> ["o",\&is_4_or_6],
		},
	"application_fs" => {
		"name"		=> ["m",\&is_cluster_app],
		"mountpnt"	=> ["m"],
		"options"	=> ["o"],
		"fstype"	=> ["m",\&is_supported_fs],
		"vg"		=> ["m",\&is_existing_vg,\&is_unique_in_cluster],
		"lv"		=> ["m",\&is_existing_lv],
		"size"		=> ["m",\&is_integer],
	},
	"cluster_events" => {
		"name"		=> ["m",],
		"event"		=> ["m",\&is_valid_cluster_event],
		"text"		=> ["m",],
		"type"		=> ["m",\&is_valid_cluster_event_type],
		"send_host"	=> ["o"],
		"send_port"	=> ["o"],
		"send_email"	=> ["o"],
		"send_file"	=> ["o"],
		"send_cmd"	=> ["o"],
	},
	"locks" => {
		"name"		=> ["m",\&is_unique,\&is_nowhitespace],
		"type"		=> ["m",\&is_host_or_cluster],
		"desc"		=> ["m"],
		"maxtime"	=> ["m",\&is_integer],
		"maxkeepers"	=> ["m",\&is_integer],
	}
);

my %records_postadd=(
);

{
my $dd=0;
my $debugmode=0;

sub _dprint {
	if(time-$dd > 60) {
		if(-f "$::ENV{TRUECL_CODE}/flags/cldb.debug") {
			$debugmode=1;
		} else {
			$debugmode=0;
		}
		$dd=time;
	}
	if($debugmode) {
		my $fd;
		open($fd,">>$::ENV{TRUECL_CODE}/log/cldb-debug.log");
		print $fd @_;
		close($fd);
	}
	if($::DEBUG==1) {
		print STDERR "DEBUG: ",@_;
	}
}

}

sub _start_n_handle_port($$) {
my $port=shift;
my $dbname=shift;
my $sub_service=undef;
my $hostname=hostname();

	_dprint "$$: Attempt to check for service on $port...\n";
	# Attempt to open service, abort if error
	my $client=new C_client2(SERVER_NAME => $hostname,SERVER_INET => $hostname,
			SERVER_PORT=>$port, PKI=>$::PKI);
	_dprint "$$: Client connection object created ok.\n";
	my ($resp,$err);
	if(defined($client)) {
		$client->set_params(TIMEOUT => 10);
		# Attempt a ping and if ok return 2 - already present.
		_dprint "$$: Client attempting to send PING message...\n";
		($resp,$err)=$client->send_request("PING");
		if(defined($resp) && $resp =~ /^OK/) {
			_dprint "$$: Service on port $port found.\n";
			return (3,$client); # service running - client
		} elsif(!defined($resp) && defined($err) && $err =~ /PROTOCOL/) {
			_dprint "$$: Protocol error: $err\n";
			return(0,$err);
		} elsif(!defined($resp)) {
			_dprint "$$: No response in timeout of 10 seconds - assuming port not available.\n";
			_dprint "$$: Error: $err\n" if defined($err);
		} else {
			_dprint "$$: Error: $err\n" if defined($err);
			_dprint "$$: Unexpected response: $resp\n";
		}
	}
	# Attempt to start service - it might already be running, 
	# and so attempt ping and drop through if so.
	_dprint "$$: No service found, attempting to start...\n";
	my $chld=fork();
	if(!defined($chld)) {
		_dprint "$$: Service could not start - fork failed. :(\n";
		return(0,undef);
	}
	if($chld==0) {
		$0="lha_confdb_service";
		# close all open file descriptors above 2..
		POSIX::close($_) foreach(4 .. 1024); # 3 is log
		$sub_service=new C_server2(PKI => $::PKI,PORT => $port);
		if(!$sub_service) {
			_dprint "$$: No service started, possibly started already...\n";
			exit(0);
		}
		_dprint "$$: Service start on pid $$.\n";
		handle_cldb_requests($sub_service,$dbname,$port);
	}
	for(1..10) {
		select(undef,undef,undef,0.25);
		# Attempt to open service, abort if error
		$client=new C_client2(SERVER_NAME => $hostname,SERVER_INET => hostname(),
				SERVER_PORT=>$port, PKI=>$::PKI);
		if(!defined($client)) {
			error("Could not define cldb service, or connect to it!",1);
		}
		$client->set_params(TIMEOUT => 10);
		# Attempt a ping and if ok return 2 - already present.
		($resp,$err)=$client->send_request("PING");
		if(defined($resp) && $resp =~ /^OK/) {
			_dprint "$$: Service on port $port found on attempt after failed server create.\n";
			return (3,$client); # service running
		}
	}
	_dprint "$$: Service could not start. :(\n";
	return (0,undef); # service not running, and could not start it
}

{
my $KEEP_ON_RUNNING=1;
my $DO_RECONFIGURE=0;
my $server=undef;
my $dbh=undef; # peristent database connection for performance
my $dbname=undef; # name of database to connect to
my $port=undef;

sub reconfigure($) {
my $server=shift;

	$server->close();
	POSIX::close($_) foreach(4 .. 1024); # 3 is log
	my $sub_service=new C_server2(PKI => $::PKI,PORT => $port);
	if(!$sub_service) {
		_dprint "$$: No service started, possibly started already...\n";
		exit(0);
	}
	_dprint "$$: Service restart on pid $$.\n";
	$sub_service->load_window_keys();
	$::SIG{USR1} = sub {$DO_RECONFIGURE=1;};
	return $sub_service;
}

sub handle_cldb_requests($$$) {
$server=shift;
$dbname=shift;
$port=shift;


	$0="lha_confdb_service";
	$::SIG{HUP} = sub {$KEEP_ON_RUNNING=1;}; # ignore and if parent dies
	$::SIG{INT} = sub {$KEEP_ON_RUNNING=0;};
	$::SIG{USR1} = sub {$DO_RECONFIGURE=1;};

	$dbh=DBI->connect("dbi:SQLite:dbname=$dbname","","",
			{
				AutoCommit => 1,
				RaiseError => 0,
				PrintError => 0,
			});
	if(!defined($dbh)) {
		::error("Unable to connect to database[$dbname] ... exiting status db sub-service.",1);
	}
	
	my $start_time=time;
	my $run_until=$start_time+2*24*60*60;
	while($KEEP_ON_RUNNING) {
		my ($request,$err)=$server->accept(2);
		last if ! $KEEP_ON_RUNNING;
		if($DO_RECONFIGURE) {
			$server=reconfigure($server);
			$DO_RECONFIGURE=0;
		}
		if(!defined($request)) {
			if(time > $run_until) {
				::msg("Config database servicing finishing for now.");
				exit(0);
			}
			# Timeout - so check locks and loop around again.	#
			next;
		}
		if($err) {
			error($err);
			next;
		}

		#################################################################
		# Handle SET_LOG_LEVEL silent|quiet|verbose|debug		#
		#################################################################
		if($request =~ /^SET_LOG_LEVEL\s+(\S+)/i) {
			my $lev=lc($1); my $ok=0;
			if($lev eq "silent")  { $ok=1; $::DEBUG=0; $::LOGGER->set_silent(); }
			if($lev eq "quiet")   { $ok=1; $::DEBUG=0; $::LOGGER->set_quiet(); }
			if($lev eq "verbose") { $ok=1; $::DEBUG=0; $::LOGGER->set_verbose(); }
			if($lev eq "debug")   { $ok=1; $::DEBUG=1; $::LOGGER->set_debug(); }
			if(! $ok) {
				$server->send_response("ERROR Log level '$lev' not recognised.");
			} else {
				$server->send_response("OK");
			}
			next;
		}

		my @F=split(/\s+/,$request);
		if($F[0] eq "ABORT") {
			$server->send_response("OK"); # Safe even if closed.
			last;
		}
		if($F[0] eq "PING" || $F[0] eq "ECHO") {
			$server->send_response("OK"); # Safe even if closed.
			next;
		}
		# Now the real reason for having this daemon, do() and getrows
		# handling... 
		# DO 0|1 REQUESTS
		# Each request is base64 encoded with "|" separating multiple
		# statements. A begin/end transaction is placed around all the
		# statements. A count of successful statements is returned, as 
		# in "OK 22 FAIL 0 b64errs".
		# If error it will abort straight away if ALL=0 (or not present).
		# If ALL=1 (first arg) keeps trying other statements too.
		# Return is "OK nn FAIL nn" again.
		# If errors, then b64errs is base64 encoded errors with "|"
		# between them,
		#
		# GET MAX SQL
		# MAX is count of maximum records to return, all matches if 0.
		# SQL is base64 encoded sql statement (optional ; at end).
		# Return values are:
		# FAIL error_msg
		# OK NN B64recoreds
		# The return value is a base64 encoded array of hashes generated 
		# via data::dumper. So eval it to get VAR1 as array reference.

		if($F[0] eq "DO") {
			if(@F!=3) {
				$server->send_response("ERROR Invalid request syntax");
				next;
			}
			$server->send_response(handle_do_request($F[1],$F[2]));
			next;
		}
		if($F[0] eq "GET") {
			if(@F!=3) {
				$server->send_response("ERROR Invalid request syntax");
				next;
			}
			$server->send_response(handle_get_request($F[1],$F[2]));
			next;
		}
		$server->send_response("ERROR Request not recognised");
	}
	::msg("Aborting on user request.");
	exit 0;
}

sub handle_do_request($$) {
my $all=shift;
my $statements=shift;

	my @S=split(/\|/,$statements);
	my $ok=0;
	my $fail=0;

	my @E=();
	for my $xx (@S) {
		my $do=decode_base64($xx);
		_dprint "$$: handle_do_request SQL=$do\n";
		$do =~ s/\s+$//;
		$do =~ s/^\s+//;
		$do =~ s/;$//;
		$do.=";";
		# ok so do is a string, so attempt to perform it...
		$dbh->{AutoCommit}=1;
		$dbh->begin_work;
		$dbh->do($do);
		$dbh->commit;
		if(defined($dbh->err)) {
			$fail++;
			push @E,$dbh->errstr;
			_dprint "$$: handle_do_request ERROR=",$dbh->errstr,"\n";
			if(! $all) {
				last;
			}
		} else {
			$ok++;
		}
	}
	my $err_str="";
	if(@E) {
		my @E2=();
		for my $ce (@E) {
			push @E2,encode_base64($ce,"");
		}
		$err_str=join("|",@E2);
		_dprint "$$: handle_do_request RETURN=OK $ok FAIL $fail $err_str\n";
		return "OK $ok FAIL $fail $err_str";
	}
	_dprint "$$: handle_do_request RETURN=OK $ok FAIL $fail\n";
	return "OK $ok FAIL $fail";
}

sub handle_get_request($$) {
my $max=shift;
my $statement=shift;

	_dprint "$$: Entered handle_get_request.\n";
	my $cd=$Data::Dumper::Indent;
	$Data::Dumper::Indent=0;
	my $do=decode_base64($statement);
	$do =~ s/\s+$//;
	$do =~ s/^\s+//;
	$do =~ s/;$//;
	$do.=";";
	_dprint "$$: SELECT='$do'\n";

	my $sth;
	eval {
		$sth=$dbh->prepare($do);
	};
	if($@ || !defined($sth)) {
		$rc=$dbh->errstr;
		_dprint "$$: Failed to prepare SQL: $rc\n";
		return "FAIL $rc";
	}
	eval {
		$sth->execute();
	};
	if($@) {
		$rc=$dbh->errstr;
		_dprint "$$: Execute failed: $rc\n";
		return "FAIL $rc";
	}
	@R=();
	my $cc=0;
	$max=99999 if $max<1;
	eval {
		while(my $aref  = $sth->fetchrow_hashref) {
			push @R,{%$aref};
			$cc++;
			last if $cc>$max;
		}
	};
	if($@) {
		$rc="Invalid SQL or no such table.";
		_dprint "$$: Fetchrow failed: $rc\n";
		return "FAIL $rc";
	}
	_dprint "$$: Grabbed $cc records.\n";
	$res=encode_base64(Dumper(\@R),"");
	_dprint "$$: Returning: 'OK $cc $res'\n";
	return "OK $cc $res";
}

}

sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self  = {};
my $dbname=shift;
my %extra=@_;

	# Attempt a connection to the sub-service...

	if(!defined($dbname)) {
		$dbname=$::ENV{TRUECL_CFG} . "/config.db";
	}
	if(exists($extra{PORT})) {
		$self->{PORT}=$extra{PORT};
	} else {
		$self->{PORT}=$::CONFDB_NPORT;
	}
	my ($rc,$service)=_start_n_handle_port($self->{PORT},$dbname);
	if($rc==3) {
		$self->{client}=$service;
		bless($self,$class);
		return $self;
	}
	if($rc==0) {
		$cldb_errcode=1;
		if(!defined($service)) {
			$cldb_errstr="Failed to start service for Config DB on port $self->{PORT}.";
		} else {
			$cldb_errstr=$service;
		}
		return undef;
	}
	die "Unexpected return code from _start_n_handle_port.";
}

#########################################################################
# Class method to return the latest error (code,string), 		#
# or undef if last call was successful.					#
#########################################################################

sub error {
	return($cldb_errcode,$cldb_errstr);
}

#########################################################################
# The force_close actually just causes the sub-process to quit. This	#
# will obviously result in the database being written out to disk.	#
#########################################################################

sub force_close($) {
my $self=shift;

	my $client=$self->{client};
	my ($resp,$err)=$client->send_request("ABORT");
	select(undef,undef,undef,1);
	return 1;
}

#########################################################################
# Instance method to execute any old SQL against the current database.	#
#########################################################################

sub do($$;$) {
my $self=shift;
my $sql=shift;
my $timeout=shift;

	$timeout=3 if !defined($timeout);
	$cldb_errcode=0;
	$cldb_errstr=undef;
	my $client=$self->{client};
	my @do_sql=();
	if(ref($sql)) {
		push @do_sql,$_ foreach (@$sql);
	} else {
		push @do_sql,$sql;
	}
	my @B=();
	for my $c (@do_sql) {
		push @B,encode_base64($c,"");
		_dprint "$$: Attempting: \"$c\"\n";
	}
	my $s=join("|",@B);
	my $cmd="DO 1 $s";
	
	my ($resp,$err)=$client->send_request($cmd);
	_dprint "$$: DO 1 result is: $resp\n";
	if($resp !~ /^OK/) {
		$resp =~ s/^(ERROR|FAIL)\s*//;
		$cldb_errcode=1;
		$cldb_errstr=$resp;
		return 0;
	}
	my @S=split(/\s+/,$resp);
	$cldb_errcode=$S[3];
	if(@S==5) {
		$cldb_errstr=decode_base64($S[4]); # errors, if present..
	}
	return $S[1]; # count of ok
}

# If we abort we need to r

sub abort() {
my $self=shift;

	my $client=$self->{client};
	my ($resp,$err)=$client->send_request("ABORT");

	select(undef,undef,undef,0.5);

	# If we abort, look for new port possibly and use that
	# for client connections ...
	my $defaults=new clmasterdefaults("$::ENV{TRUECL_CFG}/master-defaults.xml");
	if(!defined($defaults)) {
		print STDERR "ERROR: ",clmasterdefaults::error(),"\n";
	}
	my $xx=$defaults->get_default_value("configdb_port",1);
	if(defined($xx)) {
		$::CONFDB_NPORT=$xx;
	}
}

sub get_rows($$) {
my ($self,$query)=@_;

	$cldb_errcode=0;
	$cldb_errstr=undef;
	my $client=$self->{client};
	my $cmd="GET 0 ".encode_base64($query,"");
	my ($resp,$err)=$client->send_request($cmd);
	if(!defined($resp)) {
		$cldb_errcode=1;
		$cldb_errstr=$err;
		return [];
	}
	_dprint "$$: get_rows GET 0 resp=$resp\n";
	if($resp !~ /^OK/) {
		$resp =~ s/^(ERROR|FAIL)\s*//;
		$cldb_errcode=1;
		$cldb_errstr=$resp;
		return [];
	}
	my $VAR1;
	my @S=split(/\s+/,$resp);
	my $r=decode_base64($S[2]);
	_dprint "$$: Decoded get_rows response to:\n",Dumper($r);
	eval $r;
	return $VAR1;
}

# Does nothing, since autocommit is now turned on

sub commit($) {
my $self=shift;

	$cldb_errcode=0;
	$cldb_errstr=undef;
}

sub disconnect {
my $self=shift;

	# Actually we do nothing; since persistent..
	_dprint("$$: Closed database.\n");
	return;
}

sub DESTROY {
my $self=shift;

	_dprint("$$: Closed database[in DESTROY].\n");
}

sub exists($$$) {
my $self=shift;
my ($type,$obj)=@_;

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$type="table" if !defined($type);
	my $cmd="SELECT * FROM SQLITE_MASTER WHERE type = '$type' AND name = '$obj';";

	# Connect service service to get records
	my $recs=$self->get_rows($cmd);
	if(@$recs==0) {
		return 0;
	}
	return 1;
}


#########################################################################
# The add_field adds a missing field to a table and populates any	#
# records with the specified default value. It does this by 		#
# taking the table defintion for the old table and adding a		#
# field and copying all records between the two.			#
#									#
# Once complete the old table is dropped and the new table is		#
# renamed to the correct name.						#
#									#
# Returns:								#
# -1 = specified table does not exist.					#
# -2 = unable to get field definitions for table.			#
# 1  = field already present; no work required.				#
# 10+ - field added, r-10 records updated.				#
#########################################################################

sub add_field($$$$$) {
my $self=shift;
my ($table,$field,$type,$value)=@_;

	my $z=$self->contains_field($table,$field);
	if($z!=0) {
		return $z;
	}
	# Get the table defintiion information..

	my ($x,$r1,$r2)=$self->table_field_list($table);
	if($x==0) {
		return -2;
	}
	my $cmd="create table ${table}_backup(\n";
	my $cmd2="create table ${table}(\n";
	my $ii=0;
	while($ii<@$r1) {
		$cmd2.="  $r1->[$ii] $r2->[$ii],\n";
		if($ii+1==@$r1) {
			$cmd.="  $r1->[$ii] $r2->[$ii]\n";
		} else {
			$cmd.="  $r1->[$ii] $r2->[$ii],\n";
		}
		$ii++;
	}
	$cmd.=");";
	$cmd2.="  $field $type\n);";

	$self->do($cmd);
	$cmd="insert into ${table}_backup SELECT " . join(",",@$r1) . " FROM $table;";
	$self->do($cmd);
	$cmd="DROP TABLE $table;";
	$self->do($cmd);
	$self->do($cmd2);
	# Read recrods from backup to new...
	$cmd="select * from ${table}_backup;";
	my @FLIST=(@$r1,$field);
	my $flist_txt=join(",",@FLIST);
	my $rr=$self->get_rows($cmd);
	my $count=0;
	for my $crec (@$rr) {
		$crec->{$field}=$value;
		$cmd="INSERT INTO $table ($flist_txt) VALUES (";
		my $cc="";
		for my $xxx (@FLIST) {
			$cc.=",'$crec->{$xxx}'";
		}
		$cmd.=substr($cc,1) . ");";
		$self->do($cmd);
		$count++;
	}
	$cmd="DROP TABLE ${table}_backup;";
	$self->do($cmd);
	return 10+$count;
}

#########################################################################
# Returns a list of field definition lines, with any , stripped off the	#
# end of the line.							#
# (0,[],[]) - no such table.						#
# (1,[field defs],[field names])					#
#########################################################################
sub table_field_list($$) {
my $self=shift;
my $table=shift;
my ($cmd,$rc,$sth);

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$cmd="SELECT sql FROM SQLITE_MASTER WHERE type = 'table' AND name = '$table';";
	my $ii=$self->get_rows($cmd);
	my $h=undef;
	if(defined($ii) && @$ii) {
		$h=$ii->[0];
	}
	if(!defined($h)) {
		return (0,[],[]); # table does not exist
	}
	my @F=split(/\n/,$h->{sql});
	my @FF=();
	my @FF2=();
	for my $cl (@F[1 .. $#F-1]) {
		my $y=$cl;
		$y =~ s/^\s+//;
		$y =~ s/,$//;
		my @YY=split(/\s+/,$y);
		push @FF,$YY[0];
		push @FF2,$YY[1];
	}
	return(1,[@FF],[@FF2]);
}

sub contains_field($$$) {
my $self=shift;
my ($obj,$field)=@_;
my ($cmd,$rc,$sth);

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$type="table" if !defined($type);
	$cmd="SELECT sql FROM SQLITE_MASTER WHERE type = 'table' AND name = '$obj';";
	my $ii=$self->get_rows($cmd);
	my $h=undef;
	if(defined($ii) && @$ii) {
		$h=$ii->[0];
	}
	if(!defined($h)) {
		return -1; # table does not exist
	}
	my @F=split(/\n/,$h->{sql});
	for my $cl (@F[1 .. $#F-1]) {
		my $y=$cl;
		$y =~ s/^\s+//;
		my @F2=split(/\s+/,$y);
		if(lc($F2[0]) eq lc($field)) {
			return 1; # field already exists
		}
	}
	return 0; # field does not exist
}

sub get_object_schema($$$) {
my ($self,$type,$obj)=@_;

	$cldb_errcode=0;
	$cldb_errstr=undef;
	$type="table" if !defined($type);
	if(!defined($obj)) {
		$cldb_errcode=6;
		$cldb_errstr="Specified object value is undefined.";
		return undef;
	}
	my $cmd="SELECT * FROM SQLITE_MASTER WHERE type = '$type' AND name = '$obj';";
	my $r=$self->get_rows($cmd);
	if(!defined($r) || @$rr==0) {
		$cldb_errcode=8;
		$cldb_errstr="$obj of type $type does not exist.";
		return undef;
	}
	return $r->[0]->{sql};
}

sub get_record_requirements {
my ($crec,$str);

	$str="";
	for $crec (sort(keys %records)) {
		$str.=sprintf("  * %-20s ::= ",$crec);
		my $ckey;
		for $ckey (keys(%{$records{$crec}})) {
			if($records{$crec}->{$ckey}->[0] eq "m") {
				$str.="$ckey ";
			}
		}
		for $ckey (keys(%{$records{$crec}})) {
			if($records{$crec}->{$ckey}->[0] eq "o") {
				$str.="[$ckey] ";
			}
		}
		$str.="\n";
	}
	return $str;
}

sub add_verified_record {
my $self=shift;
my $ARG_table=shift;
my @ARGV=@_;
my %VALUES=();

	$cldb_errcode=0;
	$cldb_errstr=undef;

	my ($code,$val,$rc,$str);
	if(!exists($records{$ARG_table})) {
			$cldb_errcode=10;
			$cldb_errstr="Add_validated_record does not work on table '$ARG_table'.";
			return 0;
	}

	my %had=();
	foreach (@ARGV) {
		my $carg=$_;
		my ($field,$value)=split(/:/,$carg);
		$had{$field}=$value;
	}

	foreach (@ARGV) {
		my $carg=$_;
		my ($field,$value)=split(/:/,$carg);

		if(!exists($records{$ARG_table}->{$field})) {
			$cldb_errcode=10;
			$cldb_errstr="Column '$field' is not defined in table '$ARG_table'.";
			return 0;
		}

		#################################################################
		# If the field has one or more validation, formation tools,	#
		# then call it now.						#
		#################################################################

		for $code ((@{$records{$ARG_table}->{$field}})[1..9]) {
			next if !defined($code);
			next if $code eq "";
			($rc,$val)=&$code($ARG_table,$field,$value,\%had);
			if($rc) {
				$cldb_errcode=11;
				$cldb_errstr="$val";
				return 0;
			}
			$value=$val if defined($val);
		}
		$VALUES{$field}=$value;
	}

	#################################################################
	# Check to ensure that all mandatory fields have been specified	#
	# and if not then the process should abort with suitable error.	#
	#################################################################

	my @B=();
	my $ckey;
	for $ckey (keys(%{$records{$ARG_table}})) {
		if($records{$ARG_table}->{$ckey}->[0] eq "m" &&
			!exists($VALUES{$ckey})) {
			push @B,$ckey;
		}
	}
	if(@B) {
		$cldb_errcode=11;
		$cldb_errstr="Mandatory columns missing for new row on table '$ARG_table': ".join(",",@B);
		return 0;
	}

	#################################################################
	# Everything should now be in place to actually add the		#
	# record.							#
	#################################################################
	
	my $cmd="INSERT INTO $ARG_table(";
	$cmd.=join(",",(keys %VALUES));
	$cmd.=") VALUES(";
	my @L=map { "'$_'"; } (values %VALUES);
	$cmd.=join(",",@L) . ");";

	my $rcode=$self->do($cmd);
	if(!$rcode) {
		$cldb_errcode=12;
		return 0;
	} else {
		if(exists($::records_postadd{$ARG_table})) {
			($rc,$str)=&{$::records_postadd{$ARG_table}}($self,$ARG_table,%VALUES);
			if($rc) {
				$cldb_errcode=12;
				$cldb_errstr="Error occured whilst performing post add update:\n$str";
				return 0;
			}
		}
	}
	return 1;
}

#########################################################################
# Below are verification methods that should not be used directly -	#
# they are called via the add_verified_record.				#
#########################################################################

sub is_unique($$$$) {
my ($table,$field,$value,$ref)=@_;
my ($sth,$cmd,$rc);

	$cmd="SELECT * FROM $table WHERE $field = '$value';";
	my $ii=$self->get_rows($cmd);
	my $h=undef;
	if(defined($ii) && @$ii) {
		$h=$ii->[0];
	}
	if(defined($h)) {
		return(1,"Value '$value' already exists in column '$field' in table '$table'.");
	}
	return(0,undef);
}

sub is_nowhitespace($$$$) {
my ($table,$field,$value,$ref)=@_;

	cluck("here!");
	if($value =~ /\s+/) {
		return(1,"Value '$value' for column '$field' must not contain white space.");
	}
	return(0,undef);
}

sub is_mailid($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^[\w\-\.]+@([\w\-]+\.{0,1}){1,4}$/i &&
		$value =~ /[^\.]+$/) {
		return(0,undef);
	}
	return(1,"Value '$value' is not a valid Internet email address.");
}

sub encode_key($$$$) {
my ($table,$field,$value,$ref)=@_;

	my $ctx=Digest::SHA1->new;
	$ctx->add($value);
	my $hex=$ctx->hexdigest;
	return(0,$hex);
}

sub is_unixname($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^[\w\-]+$/) {
		return(0,undef);
	}
	return(1,"Value '$value' is not a valid UNIX filename.");
}

sub is_yesno($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^(y|yes|n|no)$/i) {
		return(0,uc(substr($value,0,1)));
	}
	return(1,"Value '$value' is not valid for a 'yes/no' column.");
}

sub is_valid_date($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ m{^\d{2}/\d{2}/\d{4}$}) {
		return(0,undef);
	}
	return(1,"Date must be in format 'DD/MM/YYYY'");
}

sub is_integer($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^\d+$/) {
		return(0,undef);
	}
	return(1,"Value '$value' is not a valid integer.");
}

sub is_number($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^\d+$/ || $value =~ /\d*\.\d+$/) {
		return(0,undef);
	}
	return(1,"Value '$value' is not a valid number.");
}

sub is_valid_nettype($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^failover$/i) {
		return(0,lc($value));
	}
	return(1,"Value '$value' is not a valid network type.");
}

sub is_known_cluster($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_known_cluster not yet implemented.");
}

sub is_unique_app_in_cluster($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_unique_app_in_cluster not yet implemented.");
}

sub is_valid_failover_type($$$$) {
my ($table,$field,$value,$ref)=@_;

	if($value =~ /^normal|force$/i) {
		return(0,lc($value));
	}
	return(1,"Value '$value' is not a valid failover type.");
}

sub is_sha1($$$$) {
my ($table,$field,$value,$ref)=@_;
	if($value =~ /^[a-f0-9]{40}$/i) {
		return(0,lc($value));
	}
	return(1,"Value '$value' is not a valid SHA1 hex value.");
}

#########################################################################
# App preference can be blank, LEAST_LOAD or a name of a node.		#
#########################################################################

sub is_valid_app_preference($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_valid_app_preference not yet implemented.");
}

sub is_valid_script($$$$) {
my ($table,$field,$value,$ref)=@_;

	if(! -e "$value") {
		return(2,"Script '$value' not found locally.");
	}
	return(0,undef);
}

sub is_netmask($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_valid_app_preference not yet implemented.");
}

sub is_ip_addr($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_valid_app_preference not yet implemented.");
}

sub is_4_or_6($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_valid_app_preference not yet implemented.");
}

sub is_cluster_app($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_cluster_app not yet implemented.");
}

sub is_valid_cluster_event($$$$) {
my ($table,$field,$value,$ref)=@_;
my @events=qw{node.daemon_warn node.daemon_error node.join node.leave 
	net.up net.down net.migrate node.down app.start app.end app.fail};

	if(grep {/^$value$/i} @events) {
		return(0,lc($value));
	}
	return(2,"Cluster event '$value' is not valid.");
}

sub is_valid_cluster_event_type($$$$) {
my ($table,$field,$value,$ref)=@_;
my @events=qw{email log socket cmd};

	if(grep {/^$value$/i} @events) {
		return(0,lc($value));
	}
	return(2,"Cluster event type '$value' is not valid.");
}

sub is_supported_fs($$$$) {
my ($table,$field,$value,$ref)=@_;
my @FS=qw{ext2 ext3 ext4 xfs jfs reiserfs vxfs};

	if(scalar(grep {/^$value$/i} @FS)) {
		return(0,lc($value));
	}
	return(2,"File system type '$value' has not been validated against Linuxha.net V2!");
}

sub is_existing_vg($$$$) {
my ($table,$field,$value,$ref)=@_;

	die("Routine is_existing_vg not yet implemented.");
}

sub is_unique_in_cluster($$$$) {
my ($table,$field,$value,$ref)=@_;

	# Is the VG not in use on this node for any other app/cluster
	# Does the VG exist at all.
	die("Routine is_unique_in_cluster not yet implemented.");
}

sub is_existing_lv($$$$) {
my ($table,$field,$value,$ref)=@_;

	# Does the VG/LV exist locally?
	# Does the LV_meta exist and is 128Mb in size?
	die("Routine is_existing_lv not yet implemented.");
}

sub is_host_or_cluster($$$$) {
my ($table,$field,$value,$ref)=@_;
my @FS=qw{host cluster};

	if(scalar(grep {/^$value$/i} @FS)) {
		return(0,lc($value));
	}
	return(1,"Lock type '$value' is unknown.");
}

sub is_valid_storagespec($$$$) {
my @T=qw(vxfs lvm drbd);

	if(scalar(grep {/^$value$/i} @T)) {
		return(0,lc($value));
	}
	return(1,"Storage specification type '$value' is unknown.");
}

1;

